\ VfxHarness.fth - FCOM portability harness for VFX Forth for Windows

((
Copyright (c) 2008
MicroProcessor Engineering
133 Hill Lane
Southampton SO15 5AF
England

tel:   +44 (0)23 8063 1441
fax:   +44 (0)23 8033 9691
email: mpe@mpeforth.com
       tech-support@mpeforth.com
web:   http://www.mpeforth.com
Skype: mpe_sfp

From North America, our telephone and fax numbers are:
       011 44 23 8063 1441
       011 44 23 8033 9691
       901 313 4312 (North American access number to UK office)


To do
=====

Change history
==============
))

only forth definitions
decimal

\ =============
\ *! vfxharness
\ *T VFX Forth harness to FCOM
\ =============
\ *P The file *\i{VfxHarness.fth} provides the Forth system
\ ** dependencies between VFX Forth for Windows and Tomas Dixons's
\ ** FCOM library.

\ *P There are two areas that require changes between Forth systems.
\ *(
\ *B Error handling.
\ *B How the Windows API is accessed.
\ *)


\ *****************
\ *S Error Handling
\ *****************
\ *P In order to ease error handling in complex applications, fatal
\ ** errors cause a *\fo{THROW}. Associated with each error is a
\ ** constant and (perhaps) a string. In VFX Forth, this association
\ ** is provided by *\fo{ErrDef}, which creates a constant using the
\ ** next error number and associates a string with it, e.g.
\ *C   ErrDef err_AXcreate  "Unable to create ActiveX Control"
\ *P The word *\fo{.THROW ( n -- )} can then be used to display
\ ** the corresponding string.

[undefined] ?throw [if]
: ?THROW        \ flag throw-code --
\ *G Perform a *\fo{THROW} of value *\i{throw-code} if *\i{flag}
\ ** is non-zero.
  swap if throw else drop then
;
[then]

\ *[
ErrDef err_NotDispatch  " Dispatch Interface not returned"
ErrDef err_InvBind      " Invalid Bind Type"
ErrDef err_Bind         " Unable to Bind to type"
ErrDef err_GetTypeInfo  " Unable to get type info"
ErrDef err_GetDoc       " Unable to get Documentation"
ErrDef err_LoadTypeLib  " Error Loading Type Library"
ErrDef err_GetTypeComp  " Error Getting TypeComp"
ErrDef err_NoVI         " No Virtual Interface"
ErrDef err_NotIF        " Not An Interface"
ErrDef err_VarStFull    " Variant Stack Full"
ErrDef err_CantDispatch " Unable to Call Dispatch"
ErrDef err_NoProgID     " Unable to Find ProgID"
ErrDef err_NoIUnknown   " Unable to Get IUnknown"
ErrDef err_NoValStruct  " Not a valid COM Structure"

ErrDef err_BadAlloc     " Unable to Allocate String"

ErrDef err_GUIDlen      " Invalid Guid Length"
ErrDef err_BadCLSID     " Not a CLSID"

ErrDef err_IUnknown     " Unable to get IUnknown interface"
ErrDef err_AXcreate     " Unable to create ActiveX Control"
ErrDef err_noIF         " Unable to get Interface"
\ *]


\ *********************
\ *S Windows API access
\ *********************
\ *P The FCOM library accesses API calls with the Forth stack order
\ ** reversed from that of the MSDN documentation, i.e. if MSDN
\ ** indicates:
\ *C   int foo( int a, int b,int c );
\ *P the Forth stack picture for *\fo{foo} will be:
\ *C   c b a -- int
\ *P IN other words, the left-most argument in the MSDN documentation
\ ** must be on top of the stack on entry.

\ *P To avoid name collisions and breaking existing code, FCOM
\ ** accesses words with the same name as the API call, but
\ ** preceded by 'f', e.g. the *\fo{CoCreateInstance} API call is
\ ** called through the Forth word *\fo{fCoCreateInstance}. This
\ ** arrangment permits different Forth systems to insulate their
\ ** particular standards and conventions from the FCOM library.

library: oleaut32.dll
library: ole32.dll
library: atl.dll

((
\ Native VFX Forth declarations
Extern: DWORD PASCAL StringFromCLSID( void * rclsid, void * * ppsz );
Extern: int PASCAL MultiByteToWideChar(
  UINT CodePage, DWORD dwFlags,
  void * lpMultiByteStr, int cbMultiByte,
  void * lpWideCharStr, int cchWideChar
);
Extern: int PASCAL WideCharToMultiByte(
  UINT CodePage, DWORD dwFlags,
  void * lpWideCharStr, int cchWideChar,
  void * lpMultiByteStr, int cbMultiByte,
 lpDefaultChar, lpUsedDefaultChar
);
Extern: void * PASCAL SysAllocStringLen( void * pch, int cch );
Extern: int PASCAL CoInitialize( void * rfu );
Extern: DWORD PASCAL CoCreateInstance(
  void * rclsid, void * pUnkOuter, DWORD dwClsContext, void * riid, void * * ppv
);
Extern: DWORD PASCAL CLSIDFromProgID( void * lpszProgID, void * pclsid );
Extern: HRESULT PASCAL LoadRegTypeLib(
  void * rguid, unsigned short wVerMajor, unsigned short wVerMinor, DWORD lcid, void * * pptlib
);
Extern: void PASCAL SysFreeString( void * bstr );
Extern: HRESULT PASCAL LoadTypeLib( void * szFile, void * * pptlib );
Extern: void PASCAL CoTaskMemFree( *pv );
Extern: int PASCAL AtlAxCreateControl( lpszName, hWnd, pStream, ppUnkContainer );
Extern: int "PASCAL" AtlAxGetControl( h, pp );
))

\ ********
\ *N GUIDs
\ ********

AliasedExtern: fStringFromCLSID DWORD "PASCAL" StringFromCLSID(
  void * rclsid, void * * ppsz
);
(( for DocGen
: fStringFromCLSID      \ ppsz rclsid -- res
\ *G Direct call to *\fo{StringFromCLSID()} API call.
))


\ ********************
\ *N UniCode functions
\ ********************

AliasedExtern: fMultiByteToWideChar int "PASCAL" MultiByteToWideChar(
  UINT CodePage, DWORD dwFlags,
  void * lpMultiByteStr, int cbMultiByte,
  void * lpWideCharStr, int cchWideChar
);
(( for DocGen
: fMultiByteToWideChar  \ wclen *wc mblen *mb flags cp -- int
\ *G Direct call to *\fo{MultiByteToWideChar()} API call.
))

: MB>WC         \ wclen *wc mblen *mb flags cp -- int
\ *G Convert MultiByte string to 16 bit Unicode.
  fMultiByteToWideChar
;

AliasedExtern: fWideCharToMultiByte int "PASCAL" WideCharToMultiByte(
  UINT CodePage, DWORD dwFlags,
  void * lpWideCharStr, int cchWideChar,
  void * lpMultiByteStr, int cbMultiByte,
 lpDefaultChar, lpUsedDefaultChar
);
: WC>MB         \ *used *def mblen *mb wclen *wc flags cp -- len
\ *G A direct call to the *\fo{WideCharToMultiByte()} API function.
  fWideCharToMultiByte
;

AliasedExtern: fSysAllocStringLen void * "PASCAL" SysAllocStringLen(
  void * pch, int cch
);
(( for DocGen
: fSysAllocStringLen    \ cch pch -- addr
\ *G A direct call to the *\fo{SysAllocStringLen()} API function.
))
AliasedExtern: fSysFreeString void "PASCAL" SysFreeString( void * bstr );
\ *G A direct call to the *\fo{SysFreeString()} API function.


\ *****************
\ *N COM primitives
\ *****************

AliasedExtern: fCoInitialize int "PASCAL" CoInitialize( void * rfu );
(( for DocGen
: fCoInitialize \ NULL -- hresult
\ *G A direct call to the *\fo{CoInitialize()} API function.
))

AliasedExtern: fCoCreateInstance DWORD "PASCAL" CoCreateInstance(
  void * rclsid, void * pUnkOuter, DWORD dwClsContext, void * riid, void * * ppv
);
(( for DocGen
: fCoCreateInstance     \ ppv riid context pUnkOuter rclsid -- res
\ *G A direct call to the *\fo{CoCreateInstance()} API function.
))

AliasedExtern: fCLSIDFromProgID DWORD "PASCAL" CLSIDFromProgID(
  void * lpszProgID, void * pclsid
);
(( for DocGen
: fCLSIDFromProgID      \ pclsid pprogid -- res
\ *G A direct call to the *\fo{CLSIDFromProgID()} API function.
))

AliasedExtern: fLoadRegTypeLib HRESULT "PASCAL" LoadRegTypeLib(
  void * rguid, unsigned short wVerMajor, unsigned short wVerMinor,
  DWORD lcid, void * * pptlib
);
(( for DocGen
: fLoadRegTypeLib       \ pptlib lcid wverminor wvermajor rguid -- res
\ *G A direct call to the *\fo{CLSIDFromProgID()} API function.
))

AliasedExtern: fLoadTypeLib HRESULT "PASCAL" LoadTypeLib(
  void * szFile, void * * pptlib
);
(( for DocGen
: fLoadTypeLib  \ pptlib szFile -- res
\ *G A direct call to the *\fo{LoadTypeLib()} API function.
))

AliasedExtern: fCoTaskMemFree void "PASCAL" CoTaskMemFree( *pv );
\ *G A direct call to the *\fo{CoTaskMemFree()} API function.

\ extern: int "PASCAL" CreateErrorInfo( **pperrinfo );          \ unused
\ extern: int "PASCAL" GetErrorInfo( dwReserved, **pperrinfo ); \ unused
\ extern: int "PASCAL" SetErrorInfo( dwReserved, *perrinfo );   \ unused
\ extern: int "PASCAL" LHashValOfNameSys( syskind, lcid, *szName );     \ unused


\ **********
\ *N ActiveX
\ **********

AliasedExtern: fAtlAxCreateControl int "PASCAL" AtlAxCreateControl(
  lpszName, hWnd, pStream, ppUnkContainer
);
(( for DocGen
: fAtlAxCreateControl   \ ppUnk pstream hWnd lpszName -- res
\ *G A direct call to the *\fo{AtlAxGetControl()} API function.
))
AliasedExtern: fAtlAxGetControl int "PASCAL" AtlAxGetControl( h, pp );
(( for DocGen
: fAtlAxGetControl      \ pptlib szFile -- res
\ *G A direct call to the *\fo{AtlAxGetControl()} API function.
))


\ ======
\ *> ###
\ ======

\ **** Some VFX specific behavior ****

\ Interface Calling Convention (FCOM.F)

: INTERFACE-CALL ( n1 n2 n3 ... nx a indx ) \ vtable call
   >r @ dup @ r> cells+ @ xcall ;

: RUN-INTERFACE ( pointer imethod -- ) \ runtime interface call
   cell+ @ interface-call ;

: COMPILE-INTERFACE ( pointer imethod -- ) \ fast compile interface call
   POSTPONE @ 
   POSTPONE dup 
   POSTPONE @
   cell+ @ cells POSTPONE LITERAL 
   POSTPONE + 
   POSTPONE @ 
   POSTPONE xcall ;

: RUN-VTABLE ( pointer offset -- ) 
   swap @ dup @ rot + @ xcall ;

: COMPILE-VTABLE ( pointer offset -- ) 
   POSTPONE @ 
   POSTPONE dup 
   POSTPONE @ 
   POSTPONE LITERAL
   POSTPONE + 
   POSTPONE @ 
   POSTPONE xcall ;

: laddr ( <name> -- addr ) \ returns the address of the local variable
   ['] ADDR execute ; IMMEDIATE


\ Global searching - This is system specific.

defer COMsearcher ( str len -- flag )

\ Until it gets re-defined
:noname 2drop false ; is COMsearcher 


: (comfind) ( str len -- flag )
   2dup COMsearcher 0= if 
     [ action-of cundefined literal ] execute 
   else 
     2drop 
   then ;

' (comfind) is cundefined

decimal

